home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / examples / xaw / dialog < prev    next >
Encoding:
Text File  |  1991-09-26  |  1.8 KB  |  57 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; Dialog box demo
  4.  
  5. (require 'xwidgets)
  6. (load-widgets shell ascii dialog command box label)
  7.  
  8. (define top (application-initialize 'dialog))
  9. (define dpy (widget-display top))
  10.  
  11. (define f (open-font dpy "*courier-bold-r-normal--14*"))
  12.  
  13. (define gray-bits "\10\2\10\2")
  14. (define gray (create-bitmap-from-data (display-root-window dpy) gray-bits 4 4))
  15.  
  16. (define bb (create-managed-widget (find-class 'box) top))
  17. (define quit (create-managed-widget (find-class 'command) bb 'label "Quit"))
  18. (define p (create-managed-widget (find-class 'command) bb 'label "Press me"))
  19. (define pshell (create-popup-shell (find-class 'transient-shell) top))
  20. (set-values! pshell 'width 150 'height 100)
  21.  
  22. (add-callback quit 'callback (lambda _ (exit)))
  23.  
  24. (add-callback p 'callback
  25.   (lambda _
  26.     (let* ((width (car (get-values top 'width)))
  27.       (height (car (get-values top 'height)))
  28.       (pos (widget-translate-coordinates top (truncate (/ width 2))
  29.                          (truncate (/ height 2)))))
  30.       (set-values! pshell 'x (car pos) 'y (cdr pos)))
  31.     (set-sensitive! p #f)
  32.     (set-sensitive! quit #f)
  33.     (popup pshell 'grab-nonexclusive)))
  34.  
  35. (define (dialog-popdown . _)
  36.   (popdown pshell)
  37.   (set-sensitive! p #t)
  38.   (set-sensitive! quit #t))
  39.  
  40. (define dialog (create-managed-widget (find-class 'dialog) pshell))
  41. (set-values! dialog 'background-pixmap gray)
  42. (set-values! dialog 'value "/tmp/test" 'label "Filename:")
  43. (set-values! (name->widget dialog 'value) 'font f)
  44.  
  45. (define b (create-managed-widget (find-class 'command) dialog 'label "cancel"))
  46. (add-callback b 'callback dialog-popdown)
  47.  
  48. (define b2 (create-managed-widget (find-class 'command) dialog 'label "write"))
  49. (add-callback b2 'callback
  50.   (lambda (w)
  51.     (format #t "Filename is ~s~%"
  52.         (car (get-values (widget-parent w) 'value)))
  53.     (dialog-popdown)))
  54.  
  55. (realize-widget top)
  56. (context-main-loop (widget-context top))
  57.